Supercompiler 1997/SUPERCOMPILER97.iso/Delphi 3.0/DATA.Z/checklst.pas

Pascal/Delphi Source File | 1997-01-29 | 11.3 KB | 443 lines

{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1997 Borland International        }
{                                                       }
{*******************************************************}

unit checklst;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  StdCtrls;

type
  TCheckListBox = class(TCustomListBox)
  private
    FAllowGrayed: Boolean;
    FStandardItemHeight: Integer;
    FOnClickCheck: TNotifyEvent;
    FSaveStates: TList;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure ResetItemHeight;
    procedure DrawCheck( R: TRect; AState: TCheckBoxState );
    procedure SetChecked( Index: Integer; Checked: Boolean );
    function GetChecked( Index: Integer ): Boolean;
    procedure SetState( Index: Integer; AState: TCheckBoxState );
    function GetState( Index: Integer ): TCheckBoxState;
    procedure ToggleClickCheck( Index: Integer );
    procedure InvalidateCheck( Index: Integer );
    function CreateWrapper( Index: Integer ): TObject;
    function ExtractWrapper( Index: Integer ): TObject;
    function GetWrapper( Index: Integer): TObject;
    function HaveWrapper( Index: Integer): Boolean;
  protected
    procedure DrawItem(Index: Integer; Rect: TRect;
      State: TOwnerDrawState); override;
    procedure SetItemData( Index: Integer; AData: LongInt ); override;
    function GetItemData( Index: Integer ): LongInt; override;
    procedure KeyPress(var Key: Char); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure ResetContent; override;
    procedure DeleteString(Index: Integer); override;
    procedure ClickCheck; dynamic;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    function GetCheckWidth: Integer;
  public
    destructor Destroy; override;
    property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
    property State[Index: Integer]: TCheckBoxState read GetState write SetState;
  published
    property OnClickCheck: TNotifyEvent read FOnClickCheck write FOnClickCheck;
    property Align;
    property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
    property BorderStyle;
    property Color;
    property Columns;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    //property ExtendedSelect;
    property Font;
    property ImeMode;
    property ImeName;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    //property MultiSelect;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property Style;
    property TabOrder;
    property TabStop;
    property TabWidth;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

implementation


type

  TCheckListBoxDataWrapper = class
  private
    FData: LongInt;
    FState: TCheckBoxState;
    procedure SetChecked( Check: Boolean );
    function GetChecked: Boolean;
  public
    class function GetDefaultState: TCheckBoxState;
    property Checked: Boolean read GetChecked write SetChecked;
    property State: TCheckBoxState read FState write FState;
  end;



var
  FCheckWidth, FCheckHeight: Integer;

procedure GetCheckSize;
begin
  with TBitmap.Create do
    try
      Handle := LoadBitmap( 0, PChar(32759) );
      FCheckWidth := Width div 4;
      FCheckHeight := Height div 3;
    finally
      Free;
    end;
end;

{ TCheckListBoxDataWrapper }
procedure TCheckListBoxDataWrapper.SetChecked( Check: Boolean );
begin
  if Check then FState := cbChecked else FState := cbUnchecked;
end;

function TCheckListBoxDataWrapper.GetChecked: Boolean;
begin
  Result := FState = cbChecked;
end;

class function TCheckListBoxDataWrapper.GetDefaultState: TCheckBoxState;
begin
  Result := cbUnchecked;
end;

{ TCheckListBox }
destructor TCheckListBox.Destroy;
begin
  FSaveStates.Free;
  inherited;
end;

procedure TCheckListBox.CreateWnd;
var
  I: Integer;
begin
  inherited CreateWnd;
  if FSaveStates <> nil then
  begin
    for I := 0 to Items.Count -1 do
      State[I] := TCheckBoxState(FSaveStates[I]);
    FSaveStates.Free;
    FSaveStates := nil;
  end;
  ResetItemHeight;
end;

procedure TCheckListBox.DestroyWnd;
var
  I: Integer;
  FWrappers: TList;
begin
  FWrappers := nil;
  if Items.Count > 0 then
  begin
    FSaveStates := TList.Create;
    FWrappers := TList.Create;
    for I := 0 to Items.Count -1 do
    begin
      FSaveStates.Add( TObject( State[I]) );
      FWrappers.Add( ExtractWrapper( I ) );
    end;
  end;
  inherited DestroyWnd;
  if FWrappers <> nil then
  begin
    for I := 0 to FWrappers.Count-1 do
      TCheckListBoxDataWrapper(FWrappers[I]).Free;
    FWrappers.Free;
  end;
end;

procedure TCheckListBox.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params do
    if Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE ) = 0 then
      Style := Style or LBS_OWNERDRAWFIXED;
end;

function TCheckListBox.GetCheckWidth: Integer;
begin
  Result := FCheckWidth + 2;
end;

procedure TCheckListBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  ResetItemHeight;
end;

procedure TCheckListBox.ResetItemHeight;
begin
  if Style = lbStandard then
  begin
    Canvas.Font := Font;
    FStandardItemHeight := Canvas.TextHeight('Wg');
    Perform(LB_SETITEMHEIGHT, 0, FStandardItemHeight);
  end;
end;


procedure TCheckListBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  R: TRect;
  SaveEvent: TDrawItemEvent;
begin

  if Index < Items.Count then
  begin
    R := Rect;
    R.Right := Rect.Left;
    R.Left := R.Right - GetCheckWidth;
    DrawCheck( R, GetState( Index ) );
  end;

  if (Style = lbStandard) and Assigned(OnDrawItem) then
  begin
    // Force lbStandard list to ignore OnDrawItem event.
    SaveEvent := OnDrawItem;
    OnDrawItem := nil;
    try
      inherited;
    finally
      OnDrawItem := SaveEvent;
    end;
  end
  else
    inherited;
end;


procedure TCheckListBox.CNDrawItem(var Message: TWMDrawItem);
begin
    with Message.DrawItemStruct^ do
        rcItem.Left := rcItem.Left + GetCheckWidth;
    inherited;
end;


procedure TCheckListBox.DrawCheck( R: TRect; AState: TCheckBoxState );
var
  DrawState: Integer;
  DrawRect: TRect;
begin
  case AState of
    cbChecked:
      DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED;
    cbUnchecked:
      DrawState := DFCS_BUTTONCHECK;
    else // cbGrayed
      DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED;
  end;
  DrawRect.Left := R.Left + (R.Right - R.Left - FCheckWidth) div 2;
  DrawRect.Top := R.Top + (R.Bottom - R.Top - FCheckWidth) div 2;
  DrawRect.Right := DrawRect.Left + FCheckWidth;
  DrawRect.Bottom := DrawRect.Top + FCheckHeight;

  DrawFrameControl( Canvas.Handle,
     DrawRect,  DFC_BUTTON,  DrawState);

end;



procedure TCheckListBox.SetChecked( Index: Integer; Checked: Boolean );
begin
  if Checked <> GetChecked( Index ) then
  begin
    TCheckListBoxDataWrapper(GetWrapper(Index)).SetChecked( Checked );
    InvalidateCheck( Index );
  end;
end;

procedure TCheckListBox.SetState( Index: Integer; AState: TCheckBoxState );
begin
  if AState <> GetState( Index ) then
  begin
    TCheckListBoxDataWrapper(GetWrapper(Index)).State := AState;
    InvalidateCheck( Index );
  end;
end;

procedure TCheckListBox.InvalidateCheck( Index: Integer );
var
  R: TRect;
begin
  R := ItemRect( Index );
  R.Right := R.Left + GetCheckWidth;
  InvalidateRect(Handle, @R, not (csOpaque in ControlStyle));
  UpdateWindow(Handle);
end;

function TCheckListBox.GetChecked( Index: Integer ): Boolean;
begin
  if HaveWrapper( Index ) then
    Result := TCheckListBoxDataWrapper(GetWrapper(Index)).GetChecked
  else
    Result := False;
end;

function TCheckListBox.GetState( Index: Integer ): TCheckBoxState;
begin
  if HaveWrapper( Index ) then
    Result := TCheckListBoxDataWrapper(GetWrapper(Index)).State
  else
    Result := TCheckListBoxDataWrapper.GetDefaultState;
end;

procedure TCheckListBox.KeyPress(var Key: Char);
begin
  inherited;
  if (Key = ' ') then ToggleClickCheck( ItemIndex );
end;

procedure TCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);
var
  Index: Integer;
begin
  inherited;
  Index := ItemAtPos(Point(X,Y),True);
  if Index <> -1 then
    if X - ItemRect(Index).Left < GetCheckWidth then
      ToggleClickCheck(Index);
end;


procedure TCheckListBox.ToggleClickCheck;
var
  State: TCheckBoxState;
begin
  if (Index >= 0) and (Index < Items.Count) then
  begin
    State := Self.State[Index];
    case State of
      cbUnchecked:
        if AllowGrayed then State := cbGrayed else State := cbChecked;
      cbChecked: State := cbUnchecked;
      cbGrayed: State := cbChecked;
    end;
    Self.State[Index] := State;

    ClickCheck;
  end;
end;

procedure TCheckListBox.ClickCheck;
begin
  if Assigned(FOnClickCheck) then FOnClickCheck(Self);
end;

function TCheckListBox.GetItemData(Index: Integer): LongInt;
begin
  Result := 0;
  if HaveWrapper( Index ) then
    Result := TCheckListBoxDataWrapper(GetWrapper(Index)).FData;
end;

function TCheckListBox.GetWrapper( Index: Integer ): TObject;
begin
  Result := ExtractWrapper( Index );
  if Result = nil then
    Result := CreateWrapper( Index );
end;

function TCheckListBox.ExtractWrapper( Index: Integer ): TObject;
begin
  Result := TCheckListBoxDataWrapper(inherited GetItemData( Index ));
  if (Result <> nil) and (not (Result is TCheckListBoxDataWrapper)) then
    Result := nil;
end;

function TCheckListBox.CreateWrapper( Index: Integer ): TObject;
begin
  Result := TCheckListBoxDataWrapper.Create;
  inherited SetItemData( Index, LongInt(Result) );
end;

function TCheckListBox.HaveWrapper( Index: Integer ): Boolean;
begin
  Result := ExtractWrapper( Index ) <> nil;
end;

procedure TCheckListBox.SetItemData(Index: Integer; AData: LongInt);
begin
  TCheckListBoxDataWrapper(GetWrapper( Index )).FData := AData;
end;


procedure TCheckListBox.ResetContent;
var
  I: Integer;
begin
  for I := 0 to Items.Count - 1 do
    if HaveWrapper(I) then
      GetWrapper( I ).Free;
  inherited;
end;

procedure TCheckListBox.DeleteString(Index: Integer);
begin
  if HaveWrapper(Index) then
    GetWrapper( Index ).Free;
  inherited;
end;

initialization
  GetCheckSize;

end.